home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / efs-cms.el.z / efs-cms.el
Encoding:
Text File  |  1998-05-21  |  15.3 KB  |  463 lines
  1. ;; -*-Emacs-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;; File:         efs-cms.el
  5. ;; Release:      $efs release: 1.15 $
  6. ;; Version:      #Revision: 1.9 $
  7. ;; RCS:          
  8. ;; Description:  CMS support for efs
  9. ;; Author:       Sandy Rutherford <sandy@ibm550.sissa.it>
  10. ;; Created:      Fri Oct 23 08:52:00 1992
  11. ;; Modified:     Sun Nov 27 11:46:51 1994 by sandy on gandalf
  12. ;; Language:     Emacs-Lisp
  13. ;;
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15.  
  16. ;;; This file is part of efs. See efs.el for copyright
  17. ;;; (it's copylefted) and warrranty (there isn't one) information.
  18.  
  19. (provide 'efs-cms)
  20. (require 'efs)
  21.  
  22. (defconst efs-cms-version
  23.   (concat (substring "$efs release: 1.15 $" 14 -2)
  24.       "/"
  25.       (substring "#Revision: 1.9 $" 11 -2)))
  26.  
  27. ;;;; ------------------------------------------------------------
  28. ;;;; CMS support
  29. ;;;; ------------------------------------------------------------
  30.  
  31. ;;; efs has full support, including tree dired support, for hosts running
  32. ;;; CMS.  It should be able to automatically recognize any CMS machine.
  33. ;;; We would be grateful if you would report any failures to automatically
  34. ;;; recognize a CMS host as a bug.
  35. ;;; 
  36. ;;; This should also work with CMS machines running SFS (Shared File System).
  37. ;;; 
  38. ;;; Filename syntax:
  39. ;;;
  40. ;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are
  41. ;;; treated as UNIX directories. For example to access the file READ.ME in
  42. ;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter
  43. ;;;   /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME
  44. ;;; If *.301 is the default minidisk for this account, you could access
  45. ;;; FOO.BAR on this minidisk as
  46. ;;;   /anonymous@cuvmb.cc.columbia.edu:FOO.BAR
  47. ;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be
  48. ;;; up to 8 characters. Again, beware that CMS filenames are always upper
  49. ;;; case, and hence must be entered as such.
  50. ;;;
  51. ;;; Tips:
  52. ;;; 1. CMS machines, with the exception of anonymous accounts, nearly always
  53. ;;;    need an account password. To have efs send an account password,
  54. ;;;    you can either include it in your .netrc file, or use
  55. ;;;    efs-set-account.
  56. ;;; 2. efs-set-account can be used to set account passwords for specific
  57. ;;;    minidisks. This is usually used to optain write access to the minidisk.
  58. ;;;    As well you can put tokens of the form
  59. ;;;    minidisk <minidisk name> <password> in your .netrc file. There can be
  60. ;;;    as many minidisk tokens as you like, however they should follow all
  61. ;;;    other tokens for a given machine entry. Of course, ordinary ftp
  62. ;;;    will not understand these entries in your .netrc file.
  63. ;;;
  64.  
  65.  
  66. ;;; Since CMS doesn't have any full pathname syntax, we have to fudge
  67. ;;; things with cd's. We actually send too many cd's, but is dangerous
  68. ;;; to try to remember the current minidisk, because if the connection
  69. ;;; is closed and needs to be reopened, we will find ourselves back in
  70. ;;; the default minidisk. This is fairly likely since CMS ftp servers
  71. ;;; usually close the connection after 5 minutes of inactivity.
  72.  
  73. ;;; Have I got the filename character set right?
  74.  
  75. ;;; The following three functions are entry points to this file.
  76. ;;; They have been added to the appropriate alists in efs.el
  77.  
  78. (efs-defun efs-fix-path cms (path &optional reverse)
  79.   ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert
  80.   ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax,
  81.   ;; so we fudge things by sending cd's.
  82.   (efs-save-match-data
  83.     (if reverse
  84.     (if (string-match ":" path)
  85.         ;; It's SFS
  86.         (let* ((start (match-end 0))
  87.            (return (concat "/" (substring path 0 start))))
  88.           (while (string-match "\\." path start)
  89.         (setq return (concat return "/"
  90.                      (substring path start
  91.                         (match-beginning 0)))
  92.               start (match-end 0)))
  93.           (concat return "/" (substring path start)))
  94.       ;; Since we only convert output from a pwd in this direction,
  95.       ;; we'll assume that it's a minidisk, and make it into a
  96.       ;; directory file name. Note that the expand-dir-hashtable
  97.       ;; stores directories without the trailing /.
  98.       (if (char-equal (string-to-char path) ?/)
  99.           path
  100.         (concat "/" path)))
  101.       (if (let ((case-fold-search t))
  102.         (string-match
  103.          (concat
  104.           "^/\\([-A-Z0-9$*._+:]+\\)/"
  105.           ;; In case there is a SFS
  106.           "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?"
  107.           "\\([-A-Z0-9$._+]+\\)$")
  108.          path))
  109.       (let ((minidisk (substring path 1 (match-end 1)))
  110.         (sfs (and (match-beginning 2)
  111.               (substring path (match-beginning 3)
  112.                      (match-end 3))))
  113.         (file (substring path (match-beginning 5) (match-end 5)))
  114.         account)
  115.         (and sfs (match-beginning 4)
  116.          (setq sfs (concat sfs "." (substring path (match-beginning 4)
  117.                               (1- (match-end 4))))))
  118.         (unwind-protect
  119.         (progn
  120.           (or sfs
  121.               (setq account
  122.                 (efs-get-account host user minidisk)))
  123.           (efs-raw-send-cd host user (if sfs
  124.                          (concat minidisk sfs ".")
  125.                            minidisk))
  126.           (if account
  127.               (efs-cms-send-minidisk-acct
  128.                host user minidisk account)))
  129.           (if account (fillarray account 0)))
  130.         file)
  131.     (error "Invalid CMS filename")))))
  132.  
  133. (efs-defun efs-fix-dir-path cms (dir-path)
  134.   ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing.
  135.   (efs-save-match-data
  136.     (cond
  137.      ((string-equal "/" dir-path)
  138.       (error "Cannot get listing for CMS \"/\" directory."))
  139.      ((let ((case-fold-search t))
  140.     (string-match
  141.      (concat "^/\\([-A-Z0-9$*._+:]+\\)/"
  142.          "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?"
  143.          "\\([-A-Z0-9$*_.+]+\\)?$") dir-path))
  144.       (let ((minidisk (substring dir-path (match-beginning 1) (match-end 1)))
  145.         (sfs (and (match-beginning 2)
  146.               (concat
  147.                (substring dir-path (match-beginning 3)
  148.                   (match-end 3)))))
  149.         (file (if (match-beginning 5)
  150.               (substring dir-path (match-beginning 5) (match-end 5))
  151.             "*"))
  152.         account)
  153.     (and sfs (match-beginning 4)
  154.          (setq sfs (concat sfs "." (substring dir-path
  155.                           (match-beginning 4)
  156.                           (1- (match-end 4))))))
  157.     (unwind-protect
  158.         (progn
  159.           (or sfs
  160.           (setq account (efs-get-account host user minidisk)))
  161.           (efs-raw-send-cd host user (if sfs
  162.                          (concat minidisk sfs ".")
  163.                          minidisk))
  164.           (if account
  165.           (efs-cms-send-minidisk-acct host user minidisk account)))
  166.       (if account (fillarray account 0)))
  167.     file))
  168.      (t (error "Invalid CMS pathname")))))
  169.  
  170. (defconst efs-cms-file-line-regexp
  171.   (concat
  172.    "\\([-A-Z0-9$_+]+\\) +"
  173.    "\\(\\(\\([-A-Z0-9$_+]+\\) +[VF] +[0-9]+ \\)\\|\\(DIR +- \\)\\)"))
  174.  
  175. (efs-defun efs-parse-listing cms
  176.   (host user dir path &optional switches)
  177.   ;; Parse the current buffer which is assumed to be a CMS directory listing.
  178.   ;; HOST = remote host name
  179.   ;; USER = remote user name
  180.   ;; DIR = directory as a full remote path
  181.   ;; PATH = directory as a full efs-path
  182.   (let ((tbl (efs-make-hashtable))
  183.     fn dir-p)
  184.     (goto-char (point-min))
  185.     (efs-save-match-data
  186.       (while (re-search-forward efs-cms-file-line-regexp nil t)
  187.     (if (match-beginning 3)
  188.         (setq fn (concat (buffer-substring
  189.                   (match-beginning 1) (match-end 1))
  190.                  "."
  191.                  (buffer-substring
  192.                   (match-beginning 4) (match-end 4)))
  193.           dir-p nil)
  194.       (setq fn (buffer-substring (match-beginning 1) (match-end 1))
  195.         dir-p t))
  196.     (efs-put-hash-entry fn (list dir-p) tbl)
  197.     (forward-line 1))
  198.       (efs-put-hash-entry "." '(t) tbl)
  199.       (efs-put-hash-entry ".." '(t) tbl))
  200.     tbl))
  201.  
  202. (defun efs-cms-send-minidisk-acct (host user minidisk account
  203.                     &optional noretry)
  204.   "For HOST and USER, send the account password ACCOUNT. If MINIDISK is given,
  205. the account password is for that minidisk. If PROC is given, send to that
  206. process, rathr than use HOST and USER to look up the process."
  207.   (efs-save-match-data
  208.     (let ((result (efs-raw-send-cmd
  209.            (efs-get-process host user)
  210.            (concat "quote acct " account))))
  211.       (cond
  212.        ((eq (car result) 'failed)
  213.     (setq account nil)
  214.     (unwind-protect
  215.         (progn
  216.           (setq
  217.            account
  218.            (read-passwd
  219.         (format
  220.          "Invalid acct. password for %s on %s@%s. Try again: "
  221.          minidisk user host)))
  222.           (if (string-equal "" account)
  223.           (setq account nil)))
  224.       ;; This guarantees that an interrupt will clear the account
  225.       ;; password.
  226.       (efs-set-account host user minidisk account))
  227.     (if account ; give the user another chance
  228.         (efs-cms-send-minidisk-acct host user minidisk account)))
  229.        ((eq (car result) 'fatal)
  230.     (if noretry
  231.         ;; give up
  232.         (efs-error host user
  233.                (concat "ACCOUNT password failed: " (nth 1 result)))
  234.       ;; try once more
  235.       (efs-cms-send-minidisk-acct host user minidisk account t))))
  236.       ;; return result
  237.       result)))
  238.  
  239. (efs-defun efs-write-recover cms
  240.   (line cont-lines host user cmd msg pre-cont cont nowait noretry)
  241.   ;; If a write fails because of insufficient privileges, give the user a
  242.   ;; chance to send an account password.
  243.   (let ((cmd0 (car cmd))
  244.     (cmd1 (nth 1 cmd))
  245.     (cmd2 (nth 2 cmd)))
  246.     (efs-save-match-data
  247.       (if (and (or (memq cmd0 '(append put rename))
  248.            (and (eq cmd0 'quote) (eq cmd1 'stor)))
  249.            (string-match "^/\\([-A-Z0-9$*._+]+\\)/[-A-Z0-9$*._+]+$" cmd2))
  250.       (let ((minidisk (substring cmd2 (match-beginning 1) (match-end 1)))
  251.         account retry)
  252.         (unwind-protect
  253.         (progn
  254.           (setq account
  255.             (read-passwd
  256.              (format "Account password for minidisk %s on %s@%s: "
  257.                  minidisk user host)))
  258.           (if (string-equal account "")
  259.               (setq account nil)))
  260.           (efs-set-account host user minidisk account))
  261.         (if account
  262.         (progn
  263.           (efs-cms-send-minidisk-acct host user minidisk account)
  264.           (setq retry
  265.             (efs-send-cmd host user cmd msg pre-cont cont
  266.                       nowait noretry))
  267.           (and (null (or cont nowait)) retry))
  268.           (if cont
  269.           (progn
  270.             (efs-call-cont cont 'failed line cont-lines)
  271.             nil)
  272.         (and (null nowait) (list 'failed line cont-lines)))))
  273.     (if cont
  274.         (progn
  275.           (efs-call-cont cont 'failed line cont-lines)
  276.           nil)
  277.       (and (null nowait) (list 'failed line cont-lines)))))))
  278.  
  279. (efs-defun efs-allow-child-lookup cms (host user dir file)
  280.   ;; Returns t if FILE in directory DIR could possibly be a subdir
  281.   ;; according to its file-name syntax, and therefore a child listing should
  282.   ;; be attempted.
  283.   
  284.   ;; CMS file system is flat. Only minidisks are "subdirs".
  285.   (or (string-equal "/" dir)
  286.       (efs-save-match-data
  287.     (string-match "^/[^/:]+:/$" dir))))
  288.  
  289. ;;; Sorting listings
  290.  
  291. (defconst efs-cms-date-and-time-regexp
  292.   (concat
  293.    " \\(1?[0-9]\\)/\\([0-3][0-9]\\)/\\([0-9][0-9]\\) +"
  294.    "\\([12]?[0-9]\\):\\([0-5][0-9]\\):\\([0-5][0-9]\\) "))
  295.  
  296. (efs-defun efs-t-converter cms (&optional regexp reverse)
  297.   (if regexp
  298.       nil
  299.     (goto-char (point-min))
  300.     (efs-save-match-data
  301.       (if (re-search-forward efs-cms-date-and-time-regexp nil t)
  302.       (let (list-start list bol nbol)
  303.         (beginning-of-line)
  304.         (setq list-start (point))
  305.         (while (progn
  306.              (setq bol (point))
  307.              (re-search-forward efs-cms-date-and-time-regexp
  308.                     (setq nbol (save-excursion
  309.                              (forward-line 1) (point)))
  310.                     t))
  311.           (setq list
  312.             (cons
  313.              (cons
  314.               (list (string-to-int (buffer-substring
  315.                         (match-beginning 3)
  316.                         (match-end 3))) ; year
  317.                 (string-to-int (buffer-substring
  318.                         (match-beginning 1)
  319.                         (match-end 1))) ; month
  320.                 (string-to-int (buffer-substring
  321.                         (match-beginning 2)
  322.                         (match-end 2))) ; day
  323.                 (string-to-int (buffer-substring
  324.                         (match-beginning 4)
  325.                         (match-end 4))) ; hour
  326.                 (string-to-int (buffer-substring
  327.                         (match-beginning 5)
  328.                         (match-end 5))) ; minutes
  329.                 (string-to-int (buffer-substring
  330.                         (match-beginning 6)
  331.                         (match-end 6)))) ; seconds
  332.               (buffer-substring bol nbol))
  333.              list))
  334.           (goto-char nbol))
  335.         (if list
  336.         (progn
  337.           (setq list
  338.             (mapcar 'cdr
  339.                 (sort list 'efs-cms-t-converter-sort-pred)))
  340.           (if reverse (setq list (nreverse list)))
  341.           (delete-region list-start (point))
  342.           (apply 'insert list)))
  343.         t)))))
  344.  
  345. (defun efs-cms-t-converter-sort-pred (elt1 elt2)
  346.   (let* ((data1 (car elt1))
  347.      (data2 (car elt2))
  348.      (year1 (car data1))
  349.      (year2 (car data2))
  350.      (month1 (nth 1 data1))
  351.      (month2 (nth 1 data2))
  352.      (day1 (nth 2 data1))
  353.      (day2 (nth 2 data2))
  354.      (hour1 (nth 3 data1))
  355.      (hour2 (nth 3 data2))
  356.      (minute1 (nth 4 data1))
  357.      (minute2 (nth 4 data2))
  358.      (second1 (nth 5 data1))
  359.      (second2 (nth 5 data2)))
  360.     (or (> year1 year2)
  361.     (and (= year1 year2)
  362.          (or (> month1 month2)
  363.          (and (= month1 month2)
  364.               (or (> day1 day2)
  365.               (and (= day1 day2)
  366.                    (or (> hour1 hour2)
  367.                    (and (= hour1 hour2)
  368.                     (or (> minute1 minute2)
  369.                         (and (= minute1 minute2)
  370.                          (or (> (nth 5 data1)
  371.                             (nth 5 data2)))
  372.                          ))))))))))))
  373.  
  374.  
  375. ;;; Tree dired support:
  376.  
  377. (defconst efs-dired-cms-re-exe "^. [-A-Z0-9$_+]+ +EXEC ")
  378.  
  379. (or (assq 'cms efs-dired-re-exe-alist)
  380.     (setq efs-dired-re-exe-alist
  381.       (cons (cons 'cms  efs-dired-cms-re-exe)
  382.         efs-dired-re-exe-alist)))
  383.  
  384. (defconst efs-dired-cms-re-dir "^. [-A-Z0-9$_+]+ +DIR ")
  385.  
  386. (or (assq 'cms efs-dired-re-dir-alist)
  387.     (setq efs-dired-re-dir-alist
  388.       (cons (cons 'cms  efs-dired-cms-re-dir)
  389.         efs-dired-re-dir-alist)))
  390.  
  391. (efs-defun efs-dired-insert-headerline cms (dir)
  392.   ;; CMS has no total line, so we insert a blank line for
  393.   ;; aesthetics.
  394.   (insert "\n")
  395.   (forward-char -1)
  396.   (efs-real-dired-insert-headerline dir))
  397.  
  398. (efs-defun efs-dired-manual-move-to-filename cms
  399.   (&optional raise-error bol eol)
  400.   ;; In dired, move to the first char of filename on this line.
  401.   ;; This is the CMS version.
  402.   (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point))))
  403.   (let (case-fold-search)
  404.     (if bol
  405.     (goto-char bol)
  406.       (skip-chars-backward "^\n\r")
  407.       (setq bol (point)))
  408.     (if (re-search-forward efs-cms-file-line-regexp eol t)
  409.     (goto-char (match-beginning 0))
  410.       (goto-char bol)
  411.       (and raise-error (error "No file on this line")))))
  412.  
  413. (efs-defun efs-dired-manual-move-to-end-of-filename cms
  414.   (&optional no-error bol eol)
  415.   ;; Assumes point is at beginning of filename.
  416.   ;; So, it should be called only after (dired-move-to-filename t).
  417.   ;; case-fold-search must be nil, at least for VMS.
  418.   ;; On failure, signals an error or returns nil.
  419.   ;; This is the CMS version.
  420.   (let ((opoint (point)))
  421.     (and selective-display
  422.      (null no-error)
  423.      (eq (char-after
  424.           (1- (or bol (save-excursion
  425.                 (skip-chars-backward "^\r\n")
  426.                 (point)))))
  427.          ?\r)
  428.      ;; File is hidden or omitted.
  429.      (cond
  430.       ((dired-subdir-hidden-p (dired-current-directory))
  431.        (error
  432.         (substitute-command-keys
  433.          "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
  434.       ((error
  435.         (substitute-command-keys
  436.          "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
  437.          )))))
  438.     (skip-chars-forward "-A-Z0-9$_+")
  439.     (or (looking-at " +DIR ")
  440.     (progn
  441.       (skip-chars-forward " ")
  442.       (skip-chars-forward "-A-Z0-9$_+")))
  443.     (if (or (= opoint (point)) (/= (following-char) ?\ ))
  444.     (if no-error
  445.         nil
  446.       (error "No file on this line"))
  447.       (point))))
  448.  
  449. (efs-defun efs-dired-make-filename-string cms (filename &optional reverse)
  450.   (if reverse
  451.       (if (string-match "\\." filename)
  452.       ;; Can't count on the number of blanks between the base and the
  453.       ;; extension, so ignore the extension.
  454.       (substring filename 0 (match-beginning 0))
  455.     filename)
  456.     (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" filename)
  457.     (concat (substring filename 0 (match-end 1))
  458.         "."
  459.         (substring filename (match-beginning 2) (match-end 2)))
  460.       filename)))
  461.  
  462. ;;; end of efs-cms.el
  463.